home *** CD-ROM | disk | FTP | other *** search
/ Amiga Format CD 41 / Amiga Format CD41 (1999-06)(Future Publishing)(GB)[!][issue 1999-07].iso / -seriously_amiga- / programming / other / scm / slib / chap.scm < prev    next >
Text File  |  1999-04-19  |  5KB  |  151 lines
  1. ;;;; "chap.scm" Chapter ordering        -*-scheme-*-
  2. ;;; Copyright 1992, 1993, 1994 Aubrey Jaffer.
  3. ;
  4. ;Permission to copy this software, to redistribute it, and to use it
  5. ;for any purpose is granted, subject to the following restrictions and
  6. ;understandings.
  7. ;
  8. ;1.  Any copy made of this software must include this copyright notice
  9. ;in full.
  10. ;
  11. ;2.  I have made no warrantee or representation that the operation of
  12. ;this software will be error-free, and I am under no obligation to
  13. ;provide any services, by way of maintenance, update, or otherwise.
  14. ;
  15. ;3.  In conjunction with products arising from the use of this
  16. ;material, there shall be no use of my name in any advertising,
  17. ;promotional, or sales literature without prior written consent in
  18. ;each case.
  19.  
  20. ;;; The CHAP: functions deal with strings which are ordered like
  21. ;;; chapters in a book.  For instance, a_9 < a_10 and 4c < 4aa.  Each
  22. ;;; section of the string consists of consecutive numeric or
  23. ;;; consecutive aphabetic characters.
  24.  
  25. (define (chap:string<? s1 s2)
  26.   (let ((l1 (string-length s1))
  27.     (l2 (string-length s2)))
  28.     (define (match-so-far i ctypep)
  29.       (cond ((>= i l1) (not (>= i l2)))
  30.         ((>= i l2) #f)
  31.         (else
  32.          (let ((c1 (string-ref s1 i))
  33.            (c2 (string-ref s2 i)))
  34.            (cond ((char=? c1 c2)
  35.               (if (ctypep c1)
  36.               (match-so-far (+ 1 i) ctypep)
  37.               (delimited i)))
  38.              ((ctypep c1)
  39.               (if (ctypep c2)
  40.               (length-race (+ 1 i) ctypep (char<? c1 c2))
  41.               #f))
  42.              ((ctypep c2) #t)
  43.              (else
  44.               (let ((ctype1 (ctype c1)))
  45.             (cond
  46.              ((and ctype1 (eq? ctype1 (ctype c2)))
  47.               (length-race (+ 1 i) ctype1 (char<? c1 c2)))
  48.              (else (char<? c1 c2))))))))))
  49.     (define (length-race i ctypep def)
  50.       (cond ((>= i l1) (if (>= i l2) def #t))
  51.         ((>= i l2) #f)
  52.         (else
  53.          (let ((c1 (string-ref s1 i))
  54.            (c2 (string-ref s2 i)))
  55.            (cond ((ctypep c1)
  56.               (if (ctypep c2)
  57.               (length-race (+ 1 i) ctypep def)
  58.               #f))
  59.              ((ctypep c2) #t)
  60.              (else def))))))
  61.     (define (ctype c1)
  62.       (cond
  63.        ((char-numeric? c1) char-numeric?)
  64.        ((char-lower-case? c1) char-lower-case?)
  65.        ((char-upper-case? c1) char-upper-case?)
  66.        (else #f)))
  67.     (define (delimited i)
  68.       (cond ((>= i l1) (not (>= i l2)))
  69.         ((>= i l2) #f)
  70.         (else
  71.          (let* ((c1 (string-ref s1 i))
  72.             (c2 (string-ref s2 i))
  73.             (ctype1 (ctype c1)))
  74.            (cond ((char=? c1 c2)
  75.               (if ctype1 (match-so-far (+ i 1) ctype1)
  76.               (delimited (+ i 1))))
  77.              ((and ctype1 (eq? ctype1 (ctype c2)))
  78.               (length-race (+ 1 i) ctype1 (char<? c1 c2)))
  79.              (else (char<? c1 c2)))))))
  80.     (delimited 0)))
  81.  
  82. (define chap:char-incr (- (char->integer #\2) (char->integer #\1)))
  83.  
  84. (define (chap:inc-string s p)
  85.   (let ((c (string-ref s p)))
  86.     (cond ((char=? c #\z)
  87.        (string-set! s p #\a)
  88.        (cond ((zero? p) (string-append "a" s))
  89.          ((char-lower-case? (string-ref s (+ -1 p)))
  90.           (chap:inc-string s (+ -1 p)))
  91.          (else
  92.           (string-append 
  93.            (substring s 0 p)
  94.            "a"
  95.            (substring s p (string-length s))))))
  96.       ((char=? c #\Z)
  97.        (string-set! s p #\A)
  98.        (cond ((zero? p) (string-append "A" s))
  99.          ((char-upper-case? (string-ref s (+ -1 p)))
  100.           (chap:inc-string s (+ -1 p)))
  101.          (else
  102.           (string-append 
  103.            (substring s 0 p)
  104.            "A"
  105.            (substring s p (string-length s))))))
  106.       ((char=? c #\9)
  107.        (string-set! s p #\0)
  108.        (cond ((zero? p) (string-append "1" s))
  109.          ((char-numeric? (string-ref s (+ -1 p)))
  110.           (chap:inc-string s (+ -1 p)))
  111.          (else
  112.           (string-append 
  113.            (substring s 0 p)
  114.            "1"
  115.            (substring s p (string-length s))))))
  116.       ((or (char-alphabetic? c) (char-numeric? c))
  117.        (string-set! s p (integer->char
  118.                  (+ chap:char-incr
  119.                 (char->integer (string-ref s p)))))
  120.        s)
  121.       (else (slib:error "inc-string error" s p)))))
  122.  
  123. (define (chap:next-string s)
  124.   (do ((i (+ -1 (string-length s)) (+ -1 i)))
  125.       ((or (negative? i)
  126.        (char-numeric? (string-ref s i))
  127.        (char-alphabetic? (string-ref s i)))
  128.        (if (negative? i) (string-append s "0")
  129.        (chap:inc-string (string-copy s) i)))))
  130.  
  131. ;;; testing utilities
  132. ;(define (ns s1) (chap:next-string s1))
  133.  
  134. ;(define (ts s1 s2)
  135. ;  (let ((s< (chap:string<? s1 s2))
  136. ;    (s> (chap:string<? s2 s1)))
  137. ;    (cond (s<
  138. ;       (display s1)
  139. ;       (display " < ")
  140. ;       (display s2)
  141. ;       (newline)))
  142. ;    (cond (s>
  143. ;       (display s1)
  144. ;       (display " > ")
  145. ;       (display s2)
  146. ;       (newline)))))
  147.  
  148. (define (chap:string>? s1 s2) (chap:string<? s2 s1))
  149. (define (chap:string>=? s1 s2) (not (chap:string<? s1 s2)))
  150. (define (chap:string<=? s1 s2) (not (chap:string<? s2 s1)))
  151.